home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / ada / gwuada_9.zip / GUTIL.C < prev    next >
C/C++ Source or Header  |  1993-07-27  |  15KB  |  638 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9.  
  10. #define GEN
  11.  
  12. #include "hdr.h"
  13. #include "vars.h"
  14. #include "segment.h"
  15. #include "gvars.h"
  16. #include "setp.h"
  17. #include "segmentp.h"
  18. #include "dbxp.h"
  19. #include "miscp.h"
  20. #include "gmiscp.h"
  21. #include "smiscp.h"
  22. #include "gutilp.h"
  23.  
  24. static short nature_root_type(Symbol);
  25.  
  26. extern Tuple segment_map_new(), segment_map_put();
  27. extern Segment segment_map_get();
  28. extern Segment    CODE_SEGMENT, DATA_SEGMENT, DATA_SEGMENT_MAIN;
  29.  
  30. /* create dummy entry for p (np is string with name of p)
  31.  * and call chaos if p is called
  32.  */
  33. #define undone(p, np) p() { chaos(strjoin(np, " not implemented")); }
  34.  
  35. int ada_bool(int x)                                                /*;ada_bool*/
  36. {
  37.     return (x != 0 ? 1 : 0) ;
  38. }
  39.  
  40. int assoc_symbol_exists(Symbol sym, int aname)            /*;assoc_symbol_exists*/
  41. {
  42.     /* return TRUE if assoc_symbol_get would succeed, FALSE otherwise */
  43.  
  44.     Tuple    tup;
  45.  
  46.     tup = ASSOCIATED_SYMBOLS(sym);
  47.     if (tup == (Tuple)0)
  48.         return FALSE;
  49.     else
  50.         return (tup[aname] != (char *)0);
  51. }
  52.  
  53. Symbol assoc_symbol_get(Symbol sym, int aname)            /*;assoc_symbol_get*/
  54. {
  55.     /* Enter asym as associated symbol of symbol sym. Aname is code
  56.      * definining position in tuple of associated symbols. The tuple
  57.      * is allocated if not already defined 
  58.      */
  59.  
  60.     Tuple    tup;
  61.  
  62.     tup = ASSOCIATED_SYMBOLS(sym);
  63.     if (tup == (Tuple)0)    /* if not allocated*/
  64.         chaos("assoc_symbol_get: tuple not allocated");
  65.     if (tup_size(tup)<aname)
  66.         chaos("associate_symbol_get: index out of range");
  67.     if (tup[aname] == (char *)0)
  68.         chaos("assoc_symbol_get: symbol not present");
  69.     return (Symbol) tup[aname];
  70. }
  71.  
  72. void assoc_symbol_put(Symbol sym, int aname, Symbol asym) /*;assoc_symbol_put*/
  73. {
  74.     /* Enter asym as associated symbol of symbol sym. Aname is code
  75.      * definining position in tuple of associated symbols. The tuple
  76.      * is allocated if not already defined 
  77.      */
  78.  
  79.     Tuple    tup;
  80.  
  81.     tup = ASSOCIATED_SYMBOLS(sym);
  82.     if (tup == (Tuple)0) { /* if need new tuple */
  83.         /* allocate three entries for now, should allocate proper count later */
  84.         tup = tup_new(3);
  85.         tup[1] = (char *)0;
  86.         tup[2] = (char *)0;
  87.         tup[3] = (char *)0;
  88.     }
  89.     if (tup_size(tup) < aname)
  90.         chaos("associate_symbol_put: index out of range");
  91.     tup[aname] = (char *) asym;
  92.     ASSOCIATED_SYMBOLS(sym) = tup;
  93. }
  94.  
  95. #ifdef DEBUG
  96. /* Calls to COMPILER_ERROR in SETL are translated to calls to
  97.  * commpiler_error in C. Where the SETL version builds up a string
  98.  * the C version adds a suffix to indicate argument type. For example
  99.  * compiler_error_n(s, n) to pass node. The case compiler_error_k is
  100.  * used to pass node for which the SETL version has
  101.  *    COMPILER_ERROR(s  + str N_KIND(node)
  102.  * This is written in C as
  103.  *    compiler_error_k(s, node)
  104.  * These are defined for DEBUG (base) version only. In the export version,
  105.  * they are redefined as macros (in ghdr.c) to call procedure
  106.  * exit_internal_error().
  107.  */
  108.  
  109. void compiler_error_k(char *s, Node node)                 /*;compiler_error_k*/
  110. {
  111.     printf("compiler error: %s\n", s); 
  112.     zpnod(node);
  113.     errors++;
  114.     chaos("compiler_error_k");
  115. }
  116.  
  117. void compiler_error_c(char *s, Tuple t)                    /*;compiler_error_c*/
  118. {
  119.     /* second arg is tuple corresponding to constraint*/
  120.     printf("compiler_error_c: %s\n", s);
  121.     errors++;
  122.     chaos("compile_error_c");
  123. }
  124.  
  125. void compiler_error_s(char *s, Symbol sym)                /*;compiler_error_s*/
  126. {
  127.     /* second argument is symbol */
  128.     printf("compiler_error_s: %s\n", s); 
  129.     zpsym(sym);
  130.     errors++;
  131.     chaos("compiler_error_s");
  132. }
  133. #endif
  134.  
  135. Tuple discriminant_list_get(Symbol record)            /*;discriminant_list_get*/
  136. {
  137.     /* DISCRIMINANT_LIST(record); SIGNATURE(root_type(record))(2)  */
  138.     Tuple    tup;
  139.     tup = SIGNATURE(root_type(record));
  140.     return (Tuple) tup[3];
  141. }
  142.  
  143. /* The SETL map EMAP is accessed in C by the following procedures:
  144.  *     emap_get(symbol)
  145.  *    emap_put(symbol, value)
  146.  *  Note that emap_get returns TRUE if EMAP defined for the argument,
  147.  *  and sets EMAP_VALUE to the value, or returns FALSE if the value
  148.  *  not defined.
  149.  *  The SETL sequence
  150.  *    EMAP(s) = OM;
  151.  *  is translated as
  152.  *    emap_undef(s);
  153.  */
  154.  
  155. int emap_get(Symbol sym)                                    /*;emap_get*/
  156. {
  157.     int    i, n;
  158.     n = tup_size(EMAP);
  159.     for (i = 1; i <= n; i += 2) {
  160.         if (EMAP[i] == (char *) sym) {
  161.             EMAP_VALUE = (Tuple) EMAP[i+1];
  162.             return TRUE;
  163.         }
  164.     }
  165.     return FALSE;
  166. }
  167.  
  168. void emap_put(Symbol sym, char *val)            /*;emap_put*/
  169. {
  170.     int        i, n;
  171.     n = tup_size(EMAP);
  172.     for (i = 1; i <= n; i += 2) {
  173.         if (EMAP[i] == (char *) sym) {
  174.             EMAP[i+1] = val;
  175.             return;
  176.         }
  177.     }
  178.     EMAP = tup_with(EMAP, (char *) sym); /* add as new entry */
  179.     EMAP = tup_with(EMAP, (char *) val); /* add new value */
  180. }
  181.  
  182. void emap_undef(Symbol s)                                    /*;emap_undef*/
  183. {
  184.     int    i, n, j;
  185.  
  186.     n = tup_size(EMAP);
  187.     for (i = 1; i <= n; i += 2) {
  188.         if (EMAP[i] == (char *) s) {
  189.             /* if defined here, move down later entries*/
  190.             for (j = i; j < n - 1; j ++) {
  191.                 EMAP[j] = EMAP[j+2];
  192.             }
  193.         }
  194.     }
  195. }
  196.  
  197. void generate_object(Symbol s)                            /*;generate_object*/
  198. {
  199.     if (!tup_mem((char *)s, GENERATED_OBJECTS))
  200.         GENERATED_OBJECTS = tup_with(GENERATED_OBJECTS, (char *) s);
  201. }
  202.  
  203. Tuple get_constraint(Symbol type_name)                    /*;get_constraint*/
  204. {
  205.     /* constraints on access types are now also tuples in the C version.*/
  206.     if (is_array(type_name) || NATURE(base_type(type_name)) == na_subtype) {
  207.         Tuple tup; /* TBSL: make this a static constant */
  208.         tup = tup_new(5);
  209.         tup[1] = (char *)co_index;
  210.         tup[2] = (char *)OPT_NODE;
  211.         tup[3] = (char *)OPT_NODE;
  212.         return tup;
  213.     }
  214.     else {
  215.         return SIGNATURE(type_name);
  216.     }
  217. }
  218.  
  219. Symbol get_type(Node node)                                        /*;get_type*/
  220. {
  221.     int    nk;
  222.     Symbol    sym;
  223.  
  224.     nk = N_KIND(node);
  225.     if (nk == as_simple_name || nk == as_subtype_indic) {
  226.         sym = N_UNQ(node);
  227.         if (sym == (Symbol)0) {
  228. #ifdef DEBUG
  229.             zpnod(node);
  230. #endif
  231.             chaos("get_type: N_UNQ not defined for node");
  232.         }
  233.         else {
  234.             sym =  TYPE_OF(sym);
  235.         }
  236.     }
  237.     else {
  238.         sym = N_TYPE(node);
  239.     }
  240.     return sym;
  241. }
  242.  
  243. int has_discriminant(Symbol typ)                        /*;has_discriminant*/
  244. {
  245.     /* Note that has_discriminant is adasem macro that is NOT same as
  246.      * discriminant_list macro defined in adagen. Calls of the latter must
  247.      * be translated as discriminant_list_get.
  248.      */
  249.     Tuple    tup;
  250.     tup = discriminant_list_get(typ);
  251.     if (tup == (Tuple)0) return FALSE;
  252.     return tup_size(tup) > 0;
  253. }
  254.  
  255. int has_static_size(Symbol typ)                            /*;has_static_size*/
  256. {
  257.     return size_of(typ) >= 0;
  258. }
  259.  
  260. int is_access_type(Symbol typ)                            /*;is_access_type*/
  261. {
  262.     return nature_root_type(typ) == na_access;
  263. }
  264.  
  265. int is_aggregate(Node node)                                    /*;is_aggregate*/
  266. {
  267.     register int    nk;
  268.     nk = N_KIND(node);
  269.     return nk == as_array_aggregate || nk == as_array_ivalue
  270.       ||  nk == as_record_aggregate || nk == as_record_ivalue;
  271. }
  272.  
  273. int is_array_type(Symbol typ)                            /*;is_array_type*/
  274. {
  275.     return nature_root_type(typ) == na_array;
  276. }
  277.  
  278. int is_entry_type(Symbol typ)                                /*;is_entry_type*/
  279. {
  280.     return NATURE(typ) == na_entry_former;
  281. }
  282.  
  283. int is_enumeration_type(Symbol typ)                        /*;is_enumeration_type*/
  284. {
  285.     return NATURE(root_type(typ)) == na_enum;
  286. }
  287.  
  288. int is_float_type(Symbol typ)                                /*;is_float_type*/
  289. {
  290.     Tuple    tup;
  291.     tup = SIGNATURE(typ);
  292.     return (int)tup[1] == co_digits;
  293. }
  294.  
  295. int is_formal_parameter(Symbol sym)                    /*;is_formal_parameter*/
  296. {
  297.     register int    na;
  298.     int                 s_n, found;
  299.     Symbol              same_sym, sym_scope;
  300.     Fortup              ft1;
  301.  
  302.     na = NATURE(sym);
  303.     return ((na == na_in || na == na_inout || na == na_out)
  304.             && assoc_symbol_exists(sym,FORMAL_TEMPLATE) );
  305. }
  306.  
  307. int is_global(Symbol sym)                                        /*;is_global*/
  308. {
  309.     return sym->s_segment != -1;
  310. }
  311.  
  312. int is_integer_type(Symbol typ)                                /*;is_integer_type*/
  313. {
  314.     return root_type(typ) == symbol_integer;
  315. }
  316.  
  317. int is_ivalue(Node node)                                        /*;is_ivalue*/
  318. {
  319.     int    nk = N_KIND(node);
  320.     return nk == as_ivalue || nk == as_int_literal || nk == as_string_ivalue
  321.       || nk == as_real_literal || nk == as_array_ivalue
  322.       || nk == as_record_ivalue;
  323. }
  324.  
  325. int is_object(Node node)                                        /*;is_object*/
  326. {
  327.     int    nk = N_KIND(node);
  328.     return nk == as_simple_name || nk == as_null || nk == as_name
  329.       || nk == as_slice || nk == as_index || nk == as_selector;
  330. }
  331.  
  332. int is_record_subtype(Symbol typ)                        /*;is_record_subtype*/
  333. {
  334.     return is_record_type(ty